２９−２１．日付を識別しその期間を色付け
○●●下記を"Sheet1"のクラスモジュ−ルへ記述 (14-55項でイベントの話しがあり質問があったので記載)


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 2 Then
  r = Target.Row
  If Cells(r, 1) = "" Then
     Exit Sub
  End If
     Range(Cells(r, 3), Cells(r, 34)).Select
     Selection.Interior.ColorIndex = xlNone
     Cells(r, 3).Select
    For j = 3 To 34
       hiz = Cells(r, j)
       If Cells(r, 1) <= hiz Then
           If hiz <= Cells(r, 2) Then
                Cells(r, j).Interior.ColorIndex = 3
           Else
              Exit For
           End If
       End If
   Next
End If
End Sub
・シ−トが多数の場合は各シ−ト対応に上記マクロを記述

２９−２２．相対アドレスの取得
●●●Excelでは相対アドレスを使用しないが、HTMLファイルをマクロで各種 処理する場合は必要となる。下記例は「検索エンジンもどき：KIengine」を作成 した時考えたので紹介します。


■ このマクロは始めに指定したフォルダ−を基点として、２回目以降に指定した フォルダ−の相対アドレスを取得（なお指定はファイルを1個指定して下さい）。 

Dim fff1 As String
Dim fff2 As String
Dim kai As Integer
Dim f(1, 50)

Sub eeee1()
  kai = 0
  eeee2
  kai = 1
  eeee2
End Sub
Sub eeee2()
'ダイアログ表示
If kai = 0 Then
   fsitei = "基準ファルダ−指定"
Else
   fsitei = "相対アドレスをチェックするファルダ−指定"
End If
     fff = Application.GetOpenFilename(Title:=fsitei)
     If fff = "False" Then
        MsgBox "ファイルを１個指定して下さい"
        End
     End If
     dai = fff
If kai = 0 Then
   fff1 = fff
   k = 0
Else
   fff2 = fff
   k = 1
End If
For i = 1 To 20: f(k, i) = "": Next
   
   i = 1: ssa1 = 0: fname = ""
  Do
    ssa = InStr(1, dai, "\", 1)
     ssa1 = ssa1 + ssa
    If ssa > 0 Then
        dai = Mid(dai, ssa + 1)
        ssb = InStr(1, dai, "\", 1)
        If ssb > 0 Then
           f(k, i) = Left(dai, ssb - 1)
        End If
        i = i + 1
    End If
  Loop Until ssa = 0
If kai = 0 Then
   Exit Sub
End If
'相対パス設定
  sad = ""
  For i = 1 To 50
     If f(0, i) <> f(1, i) Then
        If f(0, i) = "" Then
           sad = sad & f(1, i) & "/"
        Else
           If f(1, i) = "" Then
              sad = sad & "../"
           Else
              sad = sad & "../"
              For j = 49 To i Step -1
                 f(1, j + 1) = f(1, j)
              Next
           End If
        End If
     Else
        If f(0, i) = "" Then
            Exit For
        End If
     End If
  Next
'メッセ−ジ
 fname = Mid(fff2, ssa1)
 msg = "基点となるファルダ−" & fff1 & Chr$(10) & _
        "確認したいファルダ−" & fff2 & Chr$(10) & _
        "相対アドレスは      " & sad & fname & Chr$(10) & Chr$(10) & _
        "(他のフォルダ−も確認しますか）"
     kesu = MsgBox(msg, 4, "相対アドレス")
        If kesu = 6 Then
             eeee2
        Else
             End
        End If
End Sub

２９−２３．プログレスバ−でマクロ進捗表示
○○●Excel2000からモ−ドレスなダイアログを表示出来るように なった(モ−タブルの場合はダイアログを表示したらそのダイアログを閉じるまで 他の操作が出来ない）。下記マクロは"Show vbModeless"を指定しマクロ進捗を カラ−で表示しました。



Sub 例2923()
cend = 1500 'デバッグ用数値
'準備：ダイアログへ入力
With UserForm1
    .Caption = "マクロ実行中：しばらくお待ち下さい"
    .TextBox2.BackColor = "&h006400"
    .TextBox2.Width = 0
    .TextBox3.Width = 0
    tsiz = .TextBox1.Width
End With
'
Application.ScreenUpdating = False
UserForm1.Show vbModeless
For i = 1 To cend
    j = i / cend * 100
        With UserForm1
           .Label1.Caption = Int(j) & "%"
           .TextBox2.Width = tsiz * j / 100
           .TextBox3.SetFocus
        End With
'     ----------------------------------------------------
      For j = 1 To 10000
        'デバッグ用タイミング（実際はここに実行マクロを入れる）
      Next
     '-----------------------------------------------------
     DoEvents
Next
     Unload UserForm1

End Sub
■ このマクロを実行する場合は、ユ−ザ−フォ−ムを表示し（上記例の名前は： UserForm1）、テキストボックスを２個重ね合わせて作成する（上記例の名前は： TextBox1、TextBox2）、更に１個空いている場所の何処でもよいからテキスト ボックスを1個作る（上記例の名前は：TextBox3)。また進捗の％を数字で表示 する為のラベルを1個作成（上記例の名前は：Label1)。

■ 各テキストやラベルの名前を合わせる場合は、プロパティウインドウで オブジェクト名を変更して下さい（オブジェクト名を適当に付け、上記マクロ の名前を変える方法でもよい）

■ 上記例で"TextBox3"がありすが、これは表示幅をゼロにしてあり表示され ません。何故必要かはこのマクロで一番苦労したが"TextBox1"又は"TextBox2" にフォ−カスがあると、進捗表示と関係ない入力待ちのバ−が表示され 見ずらくなるので、そのバ−を非表示にする為フォ−カスを"TextBox3"に移した。

■ このマクロはExcel2000以外はエラ−になり使用出来ません

２９−２４．デ−タをセルの背景色から抽出
●●● ８人の生徒を４人ずつの二つのグループで試合させ、その結果をセルの色で 拾って下段の個人得点表に持ってくるものです。下段は数値が拾えて合計が出せれば セルが色づけされていなくても構いません。到達度を示すので どうしても色分けして使用したいのです。上段の表が出来上がっている （得点が記入され、セルに色を付けられている状態）前提で、 それを範囲（氏名行は除いて）にして、下段の表をつくるプログラムを 模索していますが、まったく手が出ません。よろしくお願いします。

本項は上記質問への返事。VBAに慣れてくればこの程度のマクロは10分程度 で出来ます。Forステ−トメントを多く使用したので初心者は判りずらいかも しれませんが、フロチャ−トを自分で書いてみて下さい。

 

Dim col1(10) As Integer
Dim col2 As Integer
Sub 例2924()
'各氏名の色取得
For i = 2 To 10
    If i = 6 Then
       i = i + 1
    End If
    col1(i) = Cells(2, i).Interior.ColorIndex
    Cells(2, i).Copy Cells(10, i)
Next
'色別にコピ−
For j = 3 To 7
    For i = 2 To 10
        If i = 6 Then
            i = i + 1
        End If
        col2 = Cells(j, i).Interior.ColorIndex
        For n = 2 To 10
            If col2 = col1(n) Then
                Cells(j, i).Copy Cells(j + 8, n)
                Exit For
            End If
         Next
    Next
Next
'合計計算
Range(Cells(16, 2), Cells(16, 5)).Formula = "=SUM(B11:B15)"
Range(Cells(16, 7), Cells(16, 10)).Formula = "=SUM(B11:B15)"
End Sub

２９−２５．日付制御例（年の西暦表示）
●●● (1) 左図のような和暦に対し、右図のような西暦にしたいと言う質問への返事
　　 

For i = 4 To cen1
    Application.StatusBar = "西暦化---- " & sname(cn) & i & "/" & cen1
    yer1 = Cells(i, 7)
    If yer1 < 46 Then
        Cells(i, 7) = yer1 + 1988
    Else
       Cells(i, 7) = yer1 + 1925
    End If
 Next
(2) 「△△△△　○○○○○○ 11年11月17日 ◇◇◇」(△○は文字数変化)となっておりますが、これを 「△△△△　○○○○○○ 1999/11/17 ◇◇◇」と出来ますか？、と言う質問への返事

このケ−スの場合は少しテクニックが必要です。下記の変数"top2"は文字変数でありこへに「平成」を 加えてた"top3"も文字であり、何もしなければExcelの日付シリアル値にならない。本例では シリアル値にする為に変数"top3"を日付の変数に指定した。なお"top3"の表示形式は[コントロ−ル パネル]→[地域]→[日付]で指定した表示形式となる。してがって形式が"yyyy/mm/dd"であれば変数"top3" をそのまま使用できる。しかし質問者のＰＣがどの様に設定されているか判らないのでマクロに 汎用性を持たせる為に、一度"yyyy/mm/dd"で表示しそれを"top4"へ読み取む方式を取った。

Sub 例2925()
Dim top3 As Date
   da = Cells(1, 1)
        s1 = InStr(1, da, "年", 1)
        s2 = InStr(s1, da, "日", 1)
        s3 = s2 - s1 + 3
      If s1 > 0 Then
        top2 = Mid(da, s1 - 2, s3)
      End If
  
    top3 = "平成" & top2
    Range("B1") = top3
    Range("B1").Select
    Selection.NumberFormatLocal = "yyyy/m/d"
    Range("B1") = top3
'サイズ最適化
    Columns("B:B").EntireColumn.AutoFit
    top4 = Range("B1").Text
    Range("B1") = ""
Cells(1, 1) = "△△△△　○○○○○○ " & top4 & " ◇◇◇"
End Sub

２９−２６．期限付きマクロ例
○●● 近い将来サンプルマクロとして掲載している「KIweb」をシェアウェイにしようと 考えているが、その場合も体験版として有効期限付きで掲載する予定であり、 下記マクロを考えた。

・ダウンロ−ドして最初に開いた時、その日付+10をセル"A50"へ入れる。
・一応50行目は幅"0"にして見えないようにする
・シ−トにはパスワ−ドを設定し書き換えを出来なくする
・なお、本例は「例2926b」で解除できます。
・当然マクロシ−トはプロトテクトを掛け非表示にして置きます。
 

Sub 例2926a()
     ThisWorkbook.Activate
      Sheets("Sheet1").Select
      date1 = Date
      If Cells(50, 1) = "" Then
         Rows("50:50").RowHeight = 0
         Cells(50, 1) = date1 + 10
         ActiveSheet.Protect password:="iryo"
         ActiveWorkbook.Save
         date2 = date1 + 10
         MsgBox "このKIwebは体験版で「" & date2 & "」まで有効。" & Chr$(10) & _
          Chr$(10) & "引き続き使用される方は購入してから使用して下さい"
         
      Else
         date2 = Cells(50, 1)
         If date1 < date2 Then
            MsgBox "｢" & date2 & "」で有効期限が切れました。" & Chr$(10) & _
          Chr$(10) & "引き続き使用される方は購入してから使用して下さい"
            Exit Sub
         Else
            MsgBox "このKIwebは体験版で「" & date2 & "」まで有効。" & Chr$(10) & _
          Chr$(10) & "引き続き使用される方は購入してから使用して下さい"
         End If
      End If
End Sub

Sub 例2926b()
     ThisWorkbook.Activate
      Sheets("Sheet1").Select
       ActiveSheet.Unprotect password:="iryo"
     ActiveSheet.Unprotect
     Cells(50, 1) = ""
End Sub

２９−２７．フォント取得でNullのケ−ス
●●● 同一セル内のデ−タを、部分的にフォントサイズや文字色を変えた場合 その内容を変数に取込むと（例：下記[1])、変数値は"Null"になり取込んだ 時点でマクロは正常に動作しません。その場合は下記[2]のように 事前に"IsNull"で変数化できるかチェックするとよい。 

[1]
　　　　colb = Cells(bro, c).Font.ColorIndex
　　　　siz = Cells(bro, c).Font.Size

[2]
        If IsNull(Cells(bro, c).Font.ColorIndex) = True Then
              colb = -4105
        Else
              colb = Cells(bro, c).Font.ColorIndex
        End If
                                 
        If IsNull(Cells(bro, c).Font.Size) = True Then
              siz = 11
        Else
              siz = Cells(bro, c).Font.Size
        End If

２９−２８．ワ−クシ−ト上のデ−ダ数量取得
●●● ワ−クシ−トにあるデ−タ数量を知る必要があり作成。 



Sub Macro1()
   Range("A4").CurrentRegion.Select
    cel1 = Selection.Cells.Count
    cel2 = Selection.SpecialCells(xlBlanks).Count

    Range("A1").Select
    MsgBox cel1 - cel2
End Sub

２９−２９．罫線が有るか識別しあれば色を変える
●●● 選択したセルを起点に最終行まで降りて行き、横線がある場合はその線に色を付けると共に、 縦線の場所も移動する。 



Sub Macro1()
rend = 50  '最終セル
 rs = ActiveCell.Row
 cs = ActiveCell.Column
 
Range(Cells(2, cs), Cells(2, cs + 1)).Select
    Selection.Interior.ColorIndex = 3
For i = 3 To rend
    Cells(i, cs + 1).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 3
    End With
  If i = rend Then
     Exit For
  End If
  
  If Cells(i, cs + 1).Borders(xlEdgeBottom).LineStyle = 1 Then
    Range(Cells(i, cs + 1), Cells(i, cs + 2)).Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 3
    End With
    cs = cs + 2
  ElseIf Cells(i, cs).Borders(xlEdgeBottom).LineStyle = 1 Then
    Range(Cells(i, cs), Cells(i, cs - 1)).Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 3
    End With
    cs = cs - 2
  End If
Next
Range(Cells(rend + 1, cs), Cells(rend + 1, cs + 1)).Select
 Selection.Interior.ColorIndex = 3
End Sub

２９−３０．数字のランダム抽出(乱数使用)
●●● 下記図のような図形で、ル−レットのように選択セルが変わり、ストップボタンで 数字を選択する方法を考えた。本項はランダムに数字をセルに入れた例。 


Sub aaa抽選30()
ReDim ka(1, 9)
Randomize
r = 1: c = 5
For i = 0 To 15
    ia = Int((10 - 1 + 1) * Rnd + 0)
    If i < 9 Then
         r = r + 1
        If i < 5 Then
           c = c + 1
        Else
           c = c - 1
        End If
          Cells(r, c) = ia
    Else
        r = r - 1
        If i < 13 Then
           c = c - 1
        Else
           c = c + 1
        End If
        Cells(r, c) = ia
    End If
Next
    Cells(10, 9) = ""
    Range("B1:J10").Select
     Selection.Interior.ColorIndex = xlNone
    Range("a1").Select
Range("a1").Select
End Sub
・同じ数字が何回も出てくることがあるので、実際に使用のマクロでは同一数字は２回までにしてある。
・Int((10 - 1 + 1) * Rnd + 0)で0〜9までの数字を抽出。
・前に実行の色が残っているので、Selection.Interior.ColorIndex = xlNoneで色を消去。

２９−３1．連続でセルへ色付けとストップ例
○○● ・前項図面のセルへ順次色を付け、ストップボタンにより、変数"cstp"が"1"となりDoステ−トメントより抜ける。
・本マクロ例はExcel2000以外では上手く動作しません（Excel2000ではストップが不安定）。
 

Dim cstp As Integer     'ストップ
Sub bbb抽選3()
Do
r = 1: c = 5
For i = 0 To 15
    If i < 9 Then
        Cells(r, c).Interior.ColorIndex = xlNone
         r = r + 1
        If i < 5 Then
           c = c + 1
        Else
           c = c - 1
        End If
         Cells(r, c).Interior.ColorIndex = 3
    Else
        Cells(r, c).Interior.ColorIndex = xlNone
        r = r - 1
        If i < 13 Then
           c = c - 1
        Else
           c = c + 1
        End If
        Cells(r, c).Interior.ColorIndex = 3
    End If
'タイミング
    For tm1 = 1 To 1000: For tm2 = 1 To 100: Next
          If cstp = 1 Then
             Exit For
          End If
    Next
    DoEvents
   Cells(r, c).Interior.ColorIndex = xlNone
        If cstp = 1 Then
             Exit For
        End If
Next
DoEvents
    If cstp = 1 Then
        Exit Do
    End If
Loop
    Cells(10, 9) = Cells(r, c)
    Cells(10, 9).Interior.ColorIndex = 8
    cstp = 0
End Sub
Sub ccc抽選3b()
    cstp = 1
End Sub

２９−３２．1セルのデ−タを拡大表示
○●● 抽出した文字をプロジェクタ−で大写しにしたい言う相談があり、本マクロ作成。 


Sub ddd抽選3d()
'セルをピクチャ−でコピ−
Range("I10").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Range("A1").Select
    pnam = ""
    ActiveSheet.Paste
    DoEvents
   
kaku = 1.4
For i = 1 To 7
'タイミング
For tm1 = 1 To 1000
       For tm2 = 1 To 1000
       Next
   Next
 '拡大表示
 Selection.ShapeRange.ScaleWidth kaku, msoFalse, msoScaleFromTopLeft
 Selection.ShapeRange.ScaleHeight kaku, msoFalse, msoScaleFromTopLeft
 DoEvents
Next
Range("A1").Select
End Sub

２９−３３．シ−ト上のピクチャ−を消去
○●● 前32項はセルの内容を拡大表示しますが、その図形は表示されたままの 状態になります。下記マクロでその図形を消去できる。（このマクロは 1シ−トに図形１個が前提に作成してある） 


'前の絵を消す
Sub 例2933()
shc = ActiveSheet.Pictures.Count
If shc > 0 Then
    If shc = 1 Then
        ActiveSheet.Pictures.Select
        pnam2 = Selection.Name
        ActiveSheet.Shapes(pnam2).Select
        Selection.Delete
    Else
        MsgBox "図形が" & shc & "個あります手で消去してください"
    End If
End If
End Sub

２９−３４．シ−ト上の全図形を消去
○●● 前３３項でピクチャ−を１個消すマクロを作り、３２項の拡大した絵を その都度消してから再表示で問題なかったが、ついでに全消去マクロも作成した。 


(1)全図形の消去1
Sub 例2933k1()
Dim zu As Object
    For Each zu In ActiveSheet.Shapes
        zu.Delete
    Next
End Sub

(2)全図形の消去2(本例は図形が多い時メモリー不足になる）
Sub Macro1()
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
End Sub

(3)全ピクチャ−の消去
Sub 例2933k2()
Dim zu As Object
    For Each zu In ActiveSheet.Pictures
        zu.Delete
    Next
End Sub
※　全ピクチャ−の消去で、コントロ−ルツ−ルバ−で書いたコマンドボタンは 消去されますが、フォ−ムで書いたコマンドボタンは消去されません。上手く 使い分けると便利なマクロが作成できます。

※全図形の消去は(2)のSelectAllメソッドでも出来ますが、シートに図形が多いと メモリー不足になり出来なかった。(1)の方が確実に消去できる。

２９−３５．シ−ト上の全図形のサイズ取得
○●●図形のサイズを知りたい場合は、下記例で取得できます。 


Sub 例2935()
Dim obg(10) As String      'オブジェクト名
i = 1
For Each ex In ActiveSheet.Shapes
    obg(i) = ex.Name
    ActiveSheet.Shapes(obg(i)).Select
    hei = Selection.ShapeRange.Height
    wid = Selection.ShapeRange.Width
  
    MsgBox obg(i) & "  Height " & hei
    MsgBox obg(i) & "  Width " & wid
    i = i + 1
Next
End Sub

(29-1〜29-20) (29-21〜29-35) (29-36〜29-50) (29-51〜29-61) (29-62〜29-73) (29-74〜 　　)

目次へ戻る

PC用眼鏡【管理人も使ってますがマジで疲れません】 解約手数料０円【あしたでんき】 Yahoo 楽天 NTT-X Store

無料ホームページ 無料のクレジットカード 海外格安航空券 ふるさと納税 海外旅行保険が無料！ 海外ホテル